perm filename JMCPAC.SRI[1,JMC] blob
sn#005287 filedate 1970-12-07 generic text, type T, neo UTF8
00100 BEGIN "JMC PACK ZERO WORDS"
00200 DEFINE CRLF="13&10",TRACE3="FALSE",DSKOUT="FALSE";
00300 INTEGER ARRAY WORDQ[1:70],START[0:35];
00400 INTEGER WORD,KBRK,KFLG,KEOF2,KEOF,NWORDQ,COUNT,OUTW,OUTN,WDSIN,WDSOUT;
00500 INTEGER NSTART,ISTART,DSTART,TSTART,I;
00600 LABEL BLOCK0,BLOCK1,B01,B10,CLOSALL;
00700 BOOLEAN EOFSW;
00725 STRING FILNAM;
00750 FORTRAN PROCEDURE DPYSET;
00775 FORTRAN PROCEDURE DPYOUT;
00787 FORTRAN PROCEDURE AIVECT;
00790 FORTRAN PROCEDURE AVECT;
00793 FORTRAN PROCEDURE APOINT;
00796 EXTERNAL PROCEDURE DPYSVS(INTEGER I,J;STRING S);
00800
00900 INTEGER PROCEDURE GW;
01000 BEGIN WDSIN←WDSIN+1;
01100 RETURN(WORDIN(1));
01200 END;
01300
01400 PROCEDURE PB(VALUE STRING BITS);
01500 BEGIN "PB"
01600 INTEGER L,I;
01700 IF NOT DSKOUT THEN RETURN;
01800 IF TRACE3 THEN OUTSTR(" PB("&BITS&") ");
01900 L←LENGTH(BITS);
02000 FOR I←1 STEP 1 UNTIL L DO
02100 BEGIN "ONE BIT"
02200 OUTW←OUTW+OUTW;
02300 IF BITS[I FOR 1]="0" THEN ELSE IF BITS[I FOR 1]="1"
02400 THEN OUTW←OUTW+1 ELSE USERERR(0,0,"BAD BIT TO PB");
02500 OUTN←OUTN+1;
02600 IF TRACE3 THEN OUTSTR(" **OUTN="&CVS(OUTN)&" ");
02700 IF OUTN=36 THEN BEGIN WORDOUT(2,OUTW);
02800 WDSOUT←WDSOUT+1;
02900 IF TRACE3 THEN OUTSTR("/WORDOUT:"&CVOS(OUTW)&"/ ");
03000 OUTN←0;END;
03100 END "ONE BIT";
03200 RETURN;
03300 END "PB";
03400
03500 PROCEDURE PBN(VALUE INTEGER N,BITS);
03600 BEGIN "PBN"
03700 INTEGER WASTE,I,NEED,WORK;
03800 IF NOT DSKOUT THEN RETURN;
03900 IF TRACE3 THEN OUTSTR(" PBN("&CVS(N)&" `"&CVOS(BITS)&") ");
04000 WASTE←36-N;
04100 COMMENT FOR I←1 STEP 1 UNTIL WASTE DO BITS←BITS+BITS;
04200 START_CODE "LSH BITS WASTE"
04300 MOVE 0,BITS;
04400 LSH 0,@WASTE;
04500 MOVEM 0,BITS;
04600 END "LSH BITS WASTE";
04700 IF N+OUTN≥36 THEN BEGIN "OVFL"
04800 NEED←36-OUTN;
04900 START_CODE "LSH OUTW NEED"
05000 MOVE 0,OUTW;
05100 LSH 0,@NEED;
05200 MOVEM 0,OUTW;
05300 MOVE 0,BITS;
05400 MOVN 1,OUTN;HRRZM 1,WORK;
05500 LSH 0,@WORK;
05600 MOVEM 0,WORK;
05700 END "LSH OUTW NEED";
05800 COMMENT FOR I←1 STEP 1 UNTIL NEED DO OUTW←OUTW+OUTW
05900 WORK←BITS
06000 FOR I←1 STEP 1 UNTIL OUTN DO WORK←(WORK/2) LAND '377777777777;
06100 WORDOUT(2,WORK LOR OUTW);WDSOUT←WDSOUT+1;
06200 IF TRACE3 THEN OUTSTR("/WORDLOROUT:"&CVOS(WORK LOR OUTW)&"/ ");
06300 COMMENT FOR I←1 STEP 1 UNTIL NEED DO BITS←BITS+BITS;
06400 START_CODE
06500 MOVE 0,BITS;
06600 LSH 0,@NEED;
06700 MOVEM 0,BITS;
06800 END;
06900 N←N-NEED;
07000 OUTN←0;
07100 END "OVFL";
07200 COMMENT FOR I←1 STEP 1 UNTIL N DO OUTW←OUTW+OUTW
07300 FOR I←1 STEP 1 UNTIL 36-N DO BITS←(BITS/2) LAND '377777777777;
07400 START_CODE MOVE 0,OUTW; LSH 0,@N; MOVEM 0,OUTW;
07500 MOVE 1,N; SUBI 1,36; HRRZM 1,WORK;
07600 MOVE 0,BITS; LSH 0,@WORK; MOVEM 0,BITS;
07700 END;
07800 OUTW←OUTW LOR BITS;
07900 OUTN←OUTN+N;IF TRACE3 THEN OUTSTR(" 1*OUTN="&CVS(OUTN)&" ");
08000 RETURN;
08100 END "PBN";
08200
08300 PROCEDURE EQW(VALUE INTEGER W);
08400 BEGIN "EQW"
08500 IF NWORDQ≥70 OR NWORDQ<0 THEN USERERR(0,0,"QUEUE BAD");
08600 NWORDQ←NWORDQ+1;
08700 WORDQ[NWORDQ]←W;
08800 IF TRACE3 THEN OUTSTR(" EQW#"&CVS(NWORDQ)&"='"&CVOS(W)&" ");
08900 RETURN;
09000 END "EQW";
09100
09200 PROCEDURE PW1(VALUE INTEGER W);
09300 BEGIN "PUT WORD 1"
09400 IF W=0 THEN USERERR(0,0,"ZERO WORD TO PW1");
09500 IF DSKOUT THEN BEGIN PBN(36,W);RETURN;END;
09550 IF (W LAND '200000000000)≠0 THEN RETURN;
09600 I←0;
09700 WHILE W>0 DO BEGIN W←W+W;I←I+1;END;
09800 START[I]←START[I]+1;ISTART←ISTART+1;
09900 IF ISTART≥DSTART THEN BEGIN "DRAW DPY GRAPH"
10000 INTEGER ARRAY DPYB[1:2000];
10100 INTEGER I,LOC,TOT,YLOC;
10200 DPYSET(1,DPYB[1],2000);
10250 OUTSTR(CRLF);
10300 FOR I←-360 STEP 120 UNTIL 360 DO BEGIN AIVECT(I,-400);AVECT(I,400);END;
10400 FOR I←-400 STEP 200 UNTIL 400 DO BEGIN AIVECT(-360,I);AVECT(360,I);END;
10500 LOC←-360;TOT←0;
10600 FOR I←0 STEP 1 UNTIL 35 DO BEGIN "ONE DOT"
10700 LOC←LOC+20;TOT←TOT+START[I];
10800 YLOC←-400+(800*TOT)/TSTART;
10900 APOINT(LOC,YLOC);
11000 END "ONE DOT";
11100 DPYSVS(370,-400,"0");DPYSVS(370,400,CVS(NSTART)&"↑2");
11200 DPYSVS(370,0,"MEDIAN");
11250 DPYSVS(-360,-430,"LEFTMOST ""1"" BIT IN WORDS OF FILE "&FILNAM);
11300 DPYOUT(1);ISTART←0;DSTART←DSTART+8;TSTART←TSTART+DSTART;
11400 NSTART←NSTART+2;
11500 END "DRAW DPY GRAPH";
11600 RETURN;
11700 END "PUT WORD 1";
11800
11900 PROCEDURE DQW;
12000 BEGIN "DQW"
12100 INTEGER I;
12200 IF TRACE3 THEN OUTSTR(" DQW("&CVS(NWORDQ)&") ");
12300 FOR I←1 STEP 1 UNTIL NWORDQ DO PW1(WORDQ[I]);
12400 NWORDQ←0;
12500 RETURN;
12600 END "DQW";
12700
12800 COMMENT MAINLINE BEGINS HERE;
12900 ISTART←WDSOUT←WDSIN←0;
13000 NSTART←2;DSTART←TSTART←4;
13100 FOR I←0 STEP 1 UNTIL 35 DO START[I]←0;
13200 OUTSTR("FILNAM=");
13300 OPEN(1,"DSK",8,2,0,0,KBRK,KEOF);
13350 FILNAM←INCHWL;
13400 LOOKUP(1,FILNAM,KFLG);
13500 IF KEOF≠0 OR KFLG≠0 THEN USERERR(0,0,"BAD DSK LOOKUP OR FILNAM");
13600 OPEN(2,"DSK",8,0,2,0,KBRK,KEOF);
13700 ENTER(2,"JMCPAC.TMP",KFLG);
13800 NWORDQ←OUTN←0;
13900 WORD←GW;
14000 IF WORD=0 THEN BEGIN "FIRST0"
14100 PB("0");GO BLOCK0;END "FIRST0"
14200 ELSE BEGIN "FIRST1"
14300 PB("1");EQW(WORD);GO TO BLOCK1;END "FIRST1";
14400
14500 BLOCK0: COUNT←1;
14600 WHILE KEOF=0 DO BEGIN "B0LOOP"
14700 WORD←GW;
14800 IF WORD≠0 THEN BEGIN EQW(WORD);GO TO B01;END;
14900 COUNT←COUNT+1;
15000 END "B0LOOP";
15100 PBN(36,-1);
15200 B01: IF COUNT≤1 THEN PB("0")
15300 ELSE IF COUNT≤5 THEN BEGIN "Z2T5"
15400 PB("10");PBN(2,COUNT-2);END "Z2T5"
15500 ELSE IF COUNT≤39 THEN BEGIN "Z6T39"
15600 PB("110");PBN(5,COUNT-6);END "Z6T39"
15700 ELSE IF COUNT<2↑20 THEN BEGIN "Z40T"
15800 INTEGER N,NBITS,W;
15900 PB("111");COUNT←COUNT-6;NBITS←5;W←COUNT/64;
16000 WHILE W>0 DO BEGIN PB("1");W←W/2;NBITS←NBITS+1;END;PB("0");
16100 PBN(NBITS,COUNT);IF KEOF≠0 THEN GO CLOSALL;
16200 END "Z40T"
16300 ELSE USERERR(0,0,"IMPOSSIBLE CONDITION OF MEGAWORD ALL ZERO");
16400 GO TO BLOCK1;
16500
16600 BLOCK1: COUNT←1;EOFSW←FALSE;
16700 WHILE KEOF=0 DO
16800 BEGIN "B1LOOP"
16900 WORD←GW;
17000 IF WORD=0 THEN GO TO B10;
17100 COUNT←COUNT+1;
17200 IF COUNT<71 THEN EQW(WORD)
17300 ELSE BEGIN "B71"
17400 PB("11");DQW;EQW(WORD);GO TO BLOCK1;END "B71";
17500 END "B1LOOP";
17600 EOFSW←TRUE;
17700 B10: IF COUNT≤2 THEN BEGIN "B1T2"
17800 PB("00");
17900 PBN(1,COUNT-1);END "B1T2"
18000 ELSE IF COUNT≤6 THEN BEGIN "B3T6"
18100 PB("01");PBN(2,COUNT-3);END "B3T6"
18200 ELSE BEGIN "B7T70"
18300 PB("10");PBN(6,COUNT-7);
18400 END "B7T70";
18500 DQW;
18600 IF EOFSW THEN BEGIN "BEOF"
18700 PBN(35,-1);PB("0");GO TO CLOSALL;END "BEOF";
18800 GO TO BLOCK0;
18900
19000 CLOSALL: IF DSKOUT THEN OUTSTR("////FINAL WORD?////.");
19100 IF OUTN>0 THEN BEGIN WORD←36-OUTN;
19200 START_CODE
19300 MOVE 0,OUTW; LSH 0,@WORD; MOVEM 0,OUTW;
19400 END; WORDOUT(2,OUTW);WDSOUT←WDSOUT+1; END;
19500 CLOSE(1);CLOSE(2);
19600 IF DSKOUT THEN BEGIN "REPORT"
19700 OUTSTR(CRLF&CRLF&"NUMBER OF WORDS: "&CVS(WDSIN)&"/"&CVS(WDSOUT)&".");
19800 OUTSTR(CRLF&"DSK(1280wd)BLOCKS: "&CVS((WDSIN+1278)/1280)&
19900 "/"&CVS((WDSOUT+1279)/1280)&".");END;
20000 IF DSKOUT THEN PTOSTR(0,"RU JMCUNP"&CRLF);
20100 CALL(0,"EXIT");
20200 END "JMC PACK ZERO WORDS";